{- This file is part of funbot.
 -
 - Written in 2015, 2016, 2017 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module FunBot.Memos
    ( submitMemo
    , reportMemos
    , reportAllMemos
    , dispatchPrivateMemos
    , dispatchChannelMemos
    )
where

import Control.Arrow ((***))
import Control.Monad (unless, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Data.Foldable (for_)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid ((<>))
import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
import Database.Esqueleto hiding ((%), (==.), count)
import Database.Persist
import Formatting hiding (format, sformat, text, stext)
import Formatting.Time (diff)
import Network.IRC.Fun.Bot.Chat (sendToChannel, sendToUser)
import Network.IRC.Fun.Bot.Nicks (channelIsTracked, isInChannel, presence)
import Network.IRC.Fun.Bot.State
import Network.IRC.Fun.Color
import Network.IRC.Fun.Types.Base

import qualified Database.Esqueleto as E (count)
import qualified Data.HashMap.Lazy as M
import qualified Data.HashSet as S

import FunBot.Model
import FunBot.Types hiding (Filter)
import FunBot.Util (runDB)

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

-- | Prepare an IRC message which displays a memo.
formatMemo
    :: UTCTime        -- ^ Current time
    -> Maybe Nickname -- ^ Optional recipient nickname to mention
    -> Int            -- ^ Memo index to display
    -> Memo           -- ^ Memo to format
    -> MsgContent
formatMemo now (Just recip) _idx memo =
    formatMsg
        ( text
        % ", "
        % text
        % " said "
        % diff True
        % ":\n“"
        % text
        % "”"
        )
        (unNickname recip)
        (unNickname $ memoSender memo)
        (memoTime memo `diffUTCTime` now)
        (unMsgContent $ memoContent memo)
formatMemo now Nothing idx memo =
    let n = Maroon #> plain (format ("[" % int % "]") idx)
        time = Purple #> plain (format (diff True) $ memoTime memo `diffUTCTime` now)
        sender = Gray #> "<" <> Green #> plain (unNickname $ memoSender memo) <> Gray #> ">"
        content = plain $ unMsgContent $ memoContent memo
    in  MsgContent $
        encode $ n <> " " <> time <> " " <> sender <> " " <> content

-- | Send a memo to its destination, nicely formatted.
sendMemo
    :: UTCTime  -- ^ Now
    -> Int      -- ^ Memo index number for display (i.e. 1-based)
    -> Memo     -- ^ Memo to display on IRC
    -> BotSession ()
sendMemo now idx memo =
    case memoSendIn memo of
        Just chan -> sendToChannel chan $ formatMemo now (Just recip) idx memo
        Nothing -> sendToUser recip $ formatMemo now Nothing idx memo
    where
    recip = memoRecip memo

-- | Send a memo to its destination, nicely formatted.
sendMemoList
    :: Int         -- ^ First memo's index number for display
    -> [Memo]      -- ^ Memos to display on IRC
    -> BotSession ()
sendMemoList idx ms = do
    now <- liftIO getCurrentTime
    let send (i, m) = sendMemo now i m
    mapM_ send $ zip [idx..] ms

-- | An instant memo response into the source channel or in PM.
sendInstant
    :: Nickname      -- ^ Sender nickname
    -> Maybe Channel -- ^ Source channel
    -> Nickname      -- ^ Recipient nickname
    -> MsgContent    -- ^ Message
    -> BotSession ()
sendInstant sender mchan recip content =
    case mchan of
        Just chan -> sendToChannel chan msg
        Nothing   -> sendToUser recip msg
    where
    msg = MsgContent $
        unNickname recip  <>
        ", "              <>
        unNickname sender <>
        " says: "         <>
        unMsgContent content

-- | Report to sender than their memo has been saved.
confirm
    :: Nickname       -- ^ Sender nickname
    -> Maybe Channel  -- ^ Whether sent 'Just' in channel or in PM.
    -> Nickname       -- ^ Recipient nickname
    -> BotSession ()
confirm sender (Just chan) recip = do
    sendToChannel chan $ formatMsg
        ( text
        % ", your memo for "
        % text
        % " has been saved."
        )
        (unNickname sender)
        (unNickname recip)
    t <- channelIsTracked chan
    unless t $ sendToChannel chan $ MsgContent
        "Note that tracking of user joins and quits for this channel is \
        \currently disabled in bot settings."
confirm sender Nothing recip =
    sendToUser sender $ MsgContent $
        "Your memo for " <> unNickname recip <> " has been saved."

dispatchMemos'
    :: Nickname
    -> (EntityField Memo (Maybe Channel) -> Filter Memo)
    -> Bool
    -> BotSession ()
dispatchMemos' recip mkfilt intro = runDB $ do
    let filt = [MemoRecip ==. recip, mkfilt MemoSendIn]
    memos <- map entityVal <$> selectList filt [Asc MemoTime]
    unless (null memos) $ do
        deleteWhere filt
        lift $ do
            let n = length memos
            when intro $
                sendToUser recip $
                formatMsg ("Hello! You have " % int % " private memos:") n
            sendMemoList 1 memos

-------------------------------------------------------------------------------
-- Operations
-------------------------------------------------------------------------------

dispatchMemosChannel :: Nickname -> Channel -> BotSession ()
dispatchMemosChannel recip chan = dispatchMemos' recip (==. Just chan) False

dispatchMemosChannels :: Nickname -> BotSession ()
dispatchMemosChannels recip = do
    chans <- map Just <$> presence recip
    dispatchMemos' recip (<-. chans) False

-------------------------------------------------------------------------------
-- Handlers
-------------------------------------------------------------------------------

-- | React to a user's request to make a new memo.
--
-- If user is online in same channel, send instantly to channel.
-- If user is online in another channel, send in PM (and report to sender).
-- If user not online, save memo and report to sender.
submitMemo
    :: Nickname
    -- ^ Sender nickname
    -> Maybe Channel
    -- ^ Whether sent in 'Just' a channel, or in PM
    -> Nickname
    -- ^ Recipient nickname
    -> Bool
    -- ^ Whether to always send memo privately (True) or the same as source
    -- (False)
    -> Bool
    -- ^ Whether the memo was sent as a question
    -> MsgContent
    -- ^ Memo content
    -> BotSession ()
submitMemo sender source recip private ask content = do
    let send = if private then Nothing else source
        instantToChan =
            case source of
                Just chan -> do
                    isin <- recip `isInChannel` chan
                    if isin
                        then do
                            sendInstant sender (Just chan) recip content
                            return True
                        else return False
                Nothing   -> return False
        instantToUser = do
            p <- presence recip
            if not $ null p
                then do
                    sendInstant sender Nothing recip content
                    return True
                else return False
        keepForLater = runDB $ do
            now <- liftIO getCurrentTime
            insert_ Memo
                { memoTime    = now
                , memoSender  = sender
                , memoRecip   = recip
                , memoRecvIn  = source
                , memoSendIn  = send
                , memoContent = content
                , memoAsk     = ask
                }
            lift $ confirm sender source recip
    succ1 <- instantToChan
    unless succ1 $ do
        succ2 <- instantToUser
        unless succ2 keepForLater

reportMemos
    :: Nickname -- ^ User nickname
    -> Channel  -- ^ The channel the user joined triggering the report
    -> BotSession ()
reportMemos recip chan = do
    (memosPriv, memosChan) <- runDB $ (,)
        <$> count [MemoRecip ==. recip, MemoSendIn ==. Nothing]
        <*> count [MemoRecip ==. recip, MemoSendIn ==. Just chan]
    let mp = memosPriv > 0
        mc = memosChan > 0
    p <- getStateS $ fromMaybe False . fmap fst . M.lookup recip . bsMemoReady
    when mc $
        sendToChannel chan $
            formatMsg
                ( "Hello " % nickname % "! You have " % int % " " % text
                % " in " % channel % ". Say something to see " % text % "."
                )
                recip
                memosChan
                (if memosChan == 1 then "memo" else "memos")
                chan
                (if memosChan == 1 then "it" else "them")
    when (mp && not p) $
        sendToUser recip $
            formatMsg
                ( "Hello " % nickname % "! You have " % int % " private "
                % text % ". Say something to see " % text % "."
                )
                recip
                memosPriv
                (if memosPriv == 1 then "memo" else "memos")
                (if memosPriv == 1 then "it" else "them")
    when (mp || mc) $ do
        let fp = (|| mp)
            fc = if mc then S.insert chan else id
            f = const $ fp *** fc
            v = (mp, if mc then S.singleton chan else S.empty)
        modifyState $ \ s ->
            s { bsMemoReady = M.insertWith f recip v $ bsMemoReady s }

reportAllMemos :: Nickname -> Nickname -> BotSession ()
reportAllMemos old recip = do
    modifyState $ \ s -> s { bsMemoReady = M.delete old $ bsMemoReady s }
    chansPresent <- map Just <$> presence recip
    (memosPriv, memosMaybeChans) <- runDB $ (,)
        <$> count [MemoRecip ==. recip, MemoSendIn ==. Nothing]
        <*> (select $ from $ \ m -> do
                groupBy $ m ^. MemoSendIn
                where_ $ m ^. MemoSendIn `in_` valList chansPresent
                return (m ^. MemoSendIn, E.count $ m ^. MemoSendIn)
            )
    let memosChans =
            mapMaybe
                (\ (Value mchan, Value num) -> (, num) <$> mchan)
                memosMaybeChans
        mp = memosPriv > 0
        mc = not $ null memosChans
    for_ memosChans $ \ (chan, memosChan) ->
        sendToChannel chan $
            formatMsg
                ( "Hello " % nickname % "! You have " % int % " " % text
                % " in " % channel % ". Say something to see " % text % "."
                )
                recip
                (memosChan :: Int)
                (if memosChan == 1 then "memo" else "memos")
                chan
                (if memosChan == 1 then "it" else "them")
    when mp $
        sendToUser recip $
            formatMsg
                ( "Hello " % nickname % "! You have " % int % " private "
                % text % ". Say something to see " % text % "."
                )
                recip
                memosPriv
                (if memosPriv == 1 then "memo" else "memos")
                (if memosPriv == 1 then "it" else "them")
    when (mp || mc) $ do
        let chans = S.fromList $ map fst memosChans
            fp = (|| mp)
            fc = if mc then flip S.union chans else id
            f = const $ fp *** fc
            v = (mp, chans)
        modifyState $ \ s ->
            s { bsMemoReady = M.insertWith f recip v $ bsMemoReady s }

dispatchPrivateMemos :: Nickname -> BotSession ()
dispatchPrivateMemos recip = do
    mr <- getStateS bsMemoReady
    let m = M.lookup recip mr
        mp = fromMaybe False $ fst <$> m
    when mp $ do
        dispatchMemos' recip (==. Nothing) True
        let f (_p, cs) =
                if S.null cs
                    then Nothing
                    else Just (False, cs)
        modifyState $ \ s ->
            s { bsMemoReady = M.update f recip $ bsMemoReady s }

dispatchChannelMemos :: Nickname -> Channel -> BotSession ()
dispatchChannelMemos recip chan = do
    mr <- getStateS bsMemoReady
    let m = M.lookup recip mr
        mc = fromMaybe False $ S.member chan . snd <$> m
    when mc $ do
        dispatchMemosChannel recip chan
        let f (p, cs) =
                let cs' = S.delete chan cs
                in  if S.null cs' && not p
                        then Nothing
                        else Just (p, cs')
        modifyState $ \ s ->
            s { bsMemoReady = M.update f recip $ bsMemoReady s }
